home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / basic / imb9006.zip / PRINTDBF.BAS < prev    next >
BASIC Source File  |  1990-05-16  |  10KB  |  329 lines
  1. DEFINT A-Z
  2. DECLARE FUNCTION ReadFileStructure% ()
  3. DECLARE FUNCTION RightJust$ (Value$, FieldWidth%)
  4. DECLARE FUNCTION ZeroJust$ (Number AS INTEGER)
  5. DECLARE FUNCTION ReadDbfHdr% ()
  6. DECLARE SUB DspDbfInfo ()
  7. DECLARE SUB DspFileStructure ()
  8. DECLARE SUB Pause ()
  9. DECLARE SUB PrintDbfRecord (fv$(), RecNum%)
  10. DECLARE SUB PrintReport ()
  11. DECLARE SUB ReadDbfRecord (fv$())
  12.  
  13. '=================================================
  14. '=   PROGRAM: PRINTDBF.BAS                       =
  15. '=   PURPOSE: Print listings of dBASE III+/IV    =
  16. '=            DBF files                          =
  17. '=================================================
  18.  
  19. '-------------------------------------------------
  20. ' Initialize variables and create types          -
  21. '-------------------------------------------------
  22.  
  23. CONST True = -1, False = 0
  24.  
  25. TYPE HeaderInfoType
  26.    VersionNumber AS INTEGER
  27.    LastUpdate    AS STRING * 8
  28.    NumberRecords AS LONG
  29.    HeaderLength  AS INTEGER
  30.    RecordLength  AS INTEGER
  31.    NumberFields  AS INTEGER
  32.    FileSize      AS LONG
  33. END TYPE
  34.  
  35. TYPE FieldInfoType
  36.    FdName   AS STRING * 11
  37.    FdType   AS STRING * 1
  38.    FdLength AS INTEGER
  39.    FdDec    AS INTEGER
  40. END TYPE
  41.  
  42. DIM SHARED Hdr AS HeaderInfoType
  43. DIM SHARED FileName$
  44.  
  45. FileName$ = "PLANETS.DBF"
  46.  
  47. '-------------------------------------------------
  48. '  Main processing loop                          -
  49. '-------------------------------------------------
  50.  
  51.    OPEN FileName$ FOR BINARY AS #1
  52.    CLS
  53.    ActionHdr = ReadDbfHdr
  54.    SELECT CASE ActionHdr
  55.       CASE 1
  56.          BEEP
  57.          PRINT "Not a dBASE III+ or IV file"
  58.       CASE ELSE
  59.          DspDbfInfo
  60.          Pause
  61.          DIM SHARED FLDS(Hdr.NumberFields)_
  62.                          AS FieldInfoType
  63.          ActionFile = ReadFileStructure
  64.          SELECT CASE ActionFile
  65.             CASE True
  66.                CLS
  67.                DspFileStructure
  68.                Pause
  69.                IF ActionHdr <> 2 THEN
  70.                   CLS
  71.                   PrintReport
  72.                   Pause
  73.                ELSE
  74.                   CLS
  75.                   PRINT "No records to print"
  76.                END IF
  77.             CASE False
  78.                BEEP
  79.                PRINT "Field information error"
  80.             END SELECT
  81.    END SELECT
  82.    CLOSE #1
  83.    END
  84.  
  85. SUB DspDbfInfo
  86.   
  87. '-------------------------------------------------
  88. 'Display dBASE file header information           -
  89. '-------------------------------------------------
  90.  
  91. PRINT USING "dBASE Version         : #";_
  92.                       Hdr.VersionNumber
  93. PRINT "Database in use       : "; FileName$
  94. PRINT USING "Number of data records: ########";_
  95.                              Hdr.NumberRecords
  96. PRINT "Date of last update   : "; Hdr.LastUpdate
  97. PRINT USING "Header length         :     ####";_
  98.                               Hdr.HeaderLength
  99. PRINT USING "Record length         :     ####";_
  100.                               Hdr.RecordLength
  101. PRINT USING "Number of fields      :      ###";_
  102.                               Hdr.NumberFields
  103. PRINT USING "File size             : ########";_
  104.                                   Hdr.FileSize
  105.  
  106. END SUB
  107.  
  108. SUB DspFileStructure
  109.   
  110. '-------------------------------------------------
  111. 'Purpose: Display the structure of the dBASE file-
  112. '         Name, Field Type, Length and number    -
  113. '         of decimals if a number                -
  114. '-------------------------------------------------
  115.  
  116. FieldTitleS$ =_
  117.     "Field  Field Name  Type        Width     Dec"
  118. FieldString1$ = "  ###  \         \ "
  119. FieldString2$ = "\         \   ###      ##"
  120.  
  121. PRINT : PRINT FieldTitleS$
  122.  
  123. FOR I = 1 TO Hdr.NumberFields
  124.    PRINT USING FieldString1$; I; FLDS(I).FdName;
  125.    SELECT CASE FLDS(I).FdType
  126.       CASE "C": ty$ = "Character"
  127.       CASE "L": ty$ = "Logical"
  128.       CASE "N": ty$ = "Number"
  129.       CASE "F": ty$ = "Floating Pt"
  130.       CASE "D": ty$ = "Date"
  131.       CASE "M": ty$ = "Memo"
  132.       CASE ELSE: ty$ = "Unknown"
  133.    END SELECT
  134.    PRINT USING FieldString2$; ty$;_
  135.      FLDS(I).FdLength; FLDS(I).FdDec
  136. NEXT I
  137. PRINT "   ** Total **"; TAB(33);
  138. PRINT USING "####"; Hdr.RecordLength
  139.  
  140. END SUB
  141.  
  142. SUB Pause
  143.   PRINT
  144.   PRINT "Press any key to continue"
  145.   WHILE INKEY$ = "": WEND
  146. END SUB
  147.  
  148. SUB PrintDbfRecord (fv$(), RecNum)
  149.   
  150. '-------------------------------------------------
  151. 'Purpose: Print the record to the screen.  Left  -
  152. '         justify character, date and logical    -
  153. '         fields.  Right justify numeric fields  -
  154. '         and ignore memo fields                 -
  155. 'Input  : Field values store in character array, -
  156. '         current record number                  -
  157. '-------------------------------------------------
  158.  
  159. ' Print rec # & delete status
  160. ColumnSpace = 4              'Room between columns
  161. PRINT USING "####### !"; RecNum; fv$(0);
  162.  
  163. ColumnLocation = 10          'Set current location
  164. FOR I = 1 TO Hdr.NumberFields
  165.   IF FLDS(I).FdType <> "M" THEN
  166.     PRINT TAB(ColumnLocation);
  167.     IF FLDS(I).FdType = "N" OR   _
  168.        FLDS(I).FdType = "F" THEN
  169.       PRINT RightJust$(fv$(I), FLDS(I).FdLength);
  170.     ELSE
  171.       PRINT fv$(I);
  172.     END IF
  173. '       Set next print location
  174.     ColumnLocation = ColumnLocation +_
  175.        FLDS(I).FdLength + ColumnSpace
  176.   END IF
  177. NEXT I
  178. PRINT
  179.  
  180. END SUB
  181.  
  182. SUB PrintReport
  183.   
  184. '-------------------------------------------------
  185. 'Purpose: Main printing routine                  -
  186. 'Calls  : ReadDbfRecord                          -
  187. '         PrintDbfRecord                         -
  188. '-------------------------------------------------
  189.  
  190. DIM FieldValues$(Hdr.NumberFields)
  191. PRINT : PRINT
  192. PRINT "Report on the "; FileName$; " file"
  193. PRINT
  194. FOR I = 1 TO Hdr.NumberRecords
  195.    CALL ReadDbfRecord(FieldValues$())
  196.    CALL PrintDbfRecord(FieldValues$(), I)
  197. NEXT I
  198. END SUB
  199.  
  200. FUNCTION ReadDbfHdr
  201.  
  202. '-------------------------------------------------
  203. 'Purpose: Read the dBASE file header information -
  204. '         and store in the header record         -                                        -
  205. '-------------------------------------------------
  206.  
  207. HdrStr$ = SPACE$(32)
  208. GET #1, , HdrStr$               'Read dBASE Header
  209.  
  210. Hdr.VersionNumber = ASC(LEFT$(HdrStr$, 1)) AND (7)
  211.  
  212. UpdYY$ = ZeroJust$(ASC(MID$(HdrStr$, 2, 1)))
  213. UpdMM$ = ZeroJust$(ASC(MID$(HdrStr$, 3, 1)))
  214. UpdDD$ = ZeroJust$(ASC(MID$(HdrStr$, 4, 1)))
  215.  
  216. Hdr.LastUpdate = UpdMM$+"/"+UpdDD$+"/"+UpdYY$
  217.  
  218. Hdr.NumberRecords = CVL(MID$(HdrStr$, 5, 4))
  219. Hdr.HeaderLength = CVI(MID$(HdrStr$, 9, 2))
  220. Hdr.RecordLength = CVI(MID$(HdrStr$, 11, 2))
  221.  
  222. Hdr.NumberFields = (Hdr.HeaderLength - 33) / 32
  223. Hdr.FileSize = Hdr.HeaderLength + Hdr.RecordLength_
  224.                           * Hdr.NumberRecords + 1
  225.  
  226. IF Hdr.VersionNumber <> 3 THEN
  227.    ReadDbfHdr = 1                'Not a dBASE file
  228.    EXIT FUNCTION
  229. END IF
  230.  
  231. IF Hdr.NumberRecords = 0 THEN
  232.    ReadDbfHdr = 2                'No records
  233.    EXIT FUNCTION
  234. END IF
  235. ReadDbfHdr = 0                   'No errors
  236. END FUNCTION
  237.  
  238. SUB ReadDbfRecord (fv$())
  239.   
  240. '-------------------------------------------------
  241. 'Purpose: Read a dBASE record, format date and   -
  242. '         logical fields for output              -
  243. 'Input  : Array of Field values                  -
  244. '-------------------------------------------------
  245.  
  246. F$ = SPACE$(Hdr.RecordLength)
  247. GET #1, , F$                      'Read the record
  248.  
  249. fv$(0) = LEFT$(F$, 1)    'Read deleted record mark
  250. FPOS = 2
  251.  
  252. FOR I = 1 TO Hdr.NumberFields
  253.  
  254.    fv$(I) = MID$(F$, FPOS, FLDS(I).FdLength)
  255.  
  256.    SELECT CASE FLDS(I).FdType  'Adjust field types
  257.       CASE "D"                 'Modify date format
  258.          y$ = LEFT$(fv$(I), 4)
  259.          M$ = MID$(fv$(I), 5, 2)
  260.          d$ = RIGHT$(fv$(I), 2)
  261.          fv$(I) = M$ + "/" + d$ + "/" + y$
  262.       CASE "L"                 'Standardize T or F
  263.           SELECT CASE UCASE$(fv$(I))
  264.              CASE "Y", "T": fv$(I) = ".T."
  265.              CASE "N", "F": fv$(I) = ".F."
  266.              CASE ELSE: fv$(I) = ".?."
  267.           END SELECT
  268.       CASE ELSE
  269.    END SELECT
  270.    FPOS = FPOS + FLDS(I).FdLength 'Set next fld
  271. '   PRINT fv$(I)
  272.  
  273. NEXT I
  274. END SUB
  275.  
  276. FUNCTION ReadFileStructure
  277.   
  278. '-------------------------------------------------
  279. 'Purpose: Read the file structure store in the   -
  280. '         dBASE file header.                     -
  281. '-------------------------------------------------
  282.  
  283. FOR I = 1 TO Hdr.NumberFields
  284.    Fld$ = SPACE$(32)
  285.    GET #1, , Fld$           'Get field info string
  286.    FLDS(I).FdName = LEFT$(Fld$, 11)
  287.    FLDS(I).FdType = MID$(Fld$, 12, 1)
  288.    FLDS(I).FdLength = ASC(MID$(Fld$, 17, 1))
  289.    FLDS(I).FdDec = ASC(MID$(Fld$, 18, 1))
  290. NEXT I
  291. HeaderTerminator$ = INPUT$(1, #1)   'Last hdr byte
  292. IF ASC(HeaderTerminator$) <> 13 THEN
  293.    ReadFileStructure = False       'Bad Dbf header
  294. END IF
  295. ReadFileStructure = True
  296. END FUNCTION
  297.  
  298. FUNCTION RightJust$ (Value$, FieldWidth)
  299.   
  300. '-------------------------------------------------
  301. 'Purpose: Right justify a string by padding it   -
  302. '         with spaces on the left                -
  303. 'Input  : The character value to justify, the    -
  304. '         width of the field to fit              -
  305. 'Output : A right justified string to print      -
  306. '-------------------------------------------------
  307.  
  308. RightJust$ = RIGHT$(STRING$(FieldWidth, " ") +_
  309.                           Value$, FieldWidth)
  310. END FUNCTION
  311.  
  312. DEFSNG A-Z
  313. FUNCTION ZeroJust$ (Number AS INTEGER)
  314.   
  315. '-------------------------------------------------
  316. 'Purpose: Add a leading zero to numbers less     -
  317. '         than 10 so they take as much room as   -
  318. '         numbers 10 and larger                  -
  319. 'Input  : The number to standardize              -
  320. 'Output : The adjusted number                    -
  321. '-------------------------------------------------
  322.  
  323. N$ = STR$(Number)
  324. LengthN = LEN(N$) - 1'Subtract 1 for leading space
  325. N$ = RIGHT$("0" + RIGHT$(N$, LengthN), 2)
  326. ZeroJust$ = N$
  327. END FUNCTION
  328.  
  329.